perm filename DEFVST.LSP[MAC,LSP] blob
sn#461082 filedate 1979-07-20 generic text, type C, neo UTF8
COMMENT ā VALID 00017 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 DEFVST -*-LISP-*-
C00005 00003
C00010 00004
C00013 00005
C00016 00006
C00019 00007
C00022 00008
C00025 00009
C00028 00010
C00031 00011
C00032 00012
C00034 00013
C00037 00014
C00044 00015
C00048 00016
C00051 00017
C00052 ENDMK
Cā;
;;; DEFVST -*-LISP-*-
;;; Acronym for "DEFine a Vector-like STructure"
;;; All entries in a Vector-like structure are "pointers" (FIXNUMs, LISTs, etc)
;;; Future plans call for
;;; DEFBST - "DEFine a Bitstring-like STructure", useful where
;;; the structure is an interface to some memory
;;; block required to be sequential by, say, operating
;;; system conventions, or hardware needs.
;;; DEFSTRUCT - "DEFine a general STRUCTure"
;;; which will be done by composing DEFVST and DEFBST.
;;; Vector-like structures are implemented as VECTORs, which are emulated in
;;; maclisp by HUNKs, and on the LISPMachine by 1-dimensional
;;; ART-Q arrays;
;;; Free (global) variables controlling actions:
;;; CONSTRUCTOR-NAMESTRING-PREFIX - constructor name is obtained by
;;; concatenating this string with the
;;; structure name.
;;; SELECTOR-NAMESTRING-STYLE - () ==> selector macro name is same
;;; as keyword (variable name).
;;; - "xxx" ==> selector macro name gotten
;;; by concatenating structure
;;; name, "xxx", and keyword.
;;; DEFMACRO-DISPLACE-CALL - whether or not macro instances should
;;; try to clobber with DISPLACE. See
;;; comments in DEFMAC package.
;;; Basic macros: DEFVST for defining a structure
;;; SETVST for updating a selected component
;;; (and SETF)
;;; Usage is like:
;;; (DEFVST SHIP
;;; (X-POSITION : FIXNUM)
;;; Y-POSITION
;;; (MASS = 1000.)
;;; COLOR )
;;; (SETVST (SHIP-X-POSITION QE2) 109.)
;;; or alternatively, since SETVST is abbreviated by SETF,
;;; (SETF (SHIP-X-POSITION QE2) 109.)
;;; The SETVST macro is used in conjunction with DEFVST. The example
;;; use of DEFVST "defines" a vector-like structure of 4 components;
;;; the generic name of this structure is "SHIP", and the components are
;;; identified by the ordering of what are called keywords - X-POSITION,
;;; Y-POSITION, MASS, and COLOR. Each "definition" causes the creation of
;;; 1) A constructor macro, whose name (normally) is obtained by prefixing
;;; the string "CONS-A-" onto the generic name of the structure.
;;; In the example, this becomes CONS-A-SHIP. The constructor
;;; permits installing values into the component slots at instantiation
;;; time, which are evaluated from either the (default) forms supplied
;;; by the invocation of DEFVST, or from the forms obtained by keyword
;;; parameters in the instantiating form. E.g.
;;; (CONS-A-BANK DOLLARS (PLUS 300. WALLET) MANAGER '|Jones, J.|)
;;; would put the numerical value of 300.+WALLET in the DOLLARS
;;; component of a newly-created bank, and install |Jones, J.| as
;;; its MANAGER.
;;; 2) N selector macros, one for each keyword (which denotes one
;;; component slot), which are obtained (normally) by concatenating
;;; the generic name, a "-", and the keyword name. In the example,
;;; we have SHIP-X-POSITION, SHIP-Y-POSITION, SHIP-MASS, and
;;; SHIP-COLOR.
;;; 2a: (SHIP-X-POSITION QE2)
;;; to obtain the x-coordinate of QE2
;;; 2b: (SETVST (SHIP-X-POSITION QE2) 109.)
;;; to change the x-coordinate to of QE2 to 109.
;;; 3) an information structure, stored as the STRUCT=INFO property
;;; of the generic name symbol. This information has the shape
;;; (DEFVST STRUCT=INFO
;;; INDICATOR+GENERIC-NAME
;;; CONSTRUCTOR-NAME
;;; NUMBER-OF-NAMED-COMPONENTS
;;; COMPONENT-DEFAULT-INITIALIZATION-LISTS )
;;;
;;; The indicator+generic name is a pair whose car is &STRUCT, so
;;; that there may be some chance of identifying these structures;
;;; the cdr is the name handed to DEFVST.
;;; The zero'th element of the initializations is either (), or a
;;; 3-list of the key-name, selector-name, and default size for the
;;; &REST component - the "block" of unnamed components in the
;;; structure. The remaining elements of the initializations are
;;; the "initialization lists" for each named component:
;;; (<key-name> <corresponding-selector>)
;;; ;() initial value, no restrictions
;;; (<key-name> <corresponding-selector> <ini-val-form>)
;;; ;no restrictions
;;; (<key-name> <corresponding-selector>
;;; <ini-val-form> . <list-of-types-for-restrictions>)
;;;
;;; Using the ABBREV macro (see LIBDOC;ABBREV >), one can selectively
;;; use other names, but the canonical constructor and canonical
;;; selector names will still be created at define time. E.g.
;;; (ABBREVIATION MG BANK-MANAGER SENDOFF CONS-A-SHIP)
;;; CONSTRAINTS, and INITIAL VALUES
;;; Each of the components may be constrained to be a particular
;;; type datum, and may be initialized according to the form supplied
;;; as default by the call to DEFVST.
;;;
;;; The syntax for a non-simple component specification is a list with
;;; the first element being the key name, the item following the first
;;; "=" in the list being a form which is the default form to be evaluated
;;; for that component in any creations of instances of that structure,
;;; and the element following the first ":" is either a type name or list
;;; of type names that restricts any creating instance from supplying an
;;; initial value of the wrong type. If a key has a restriction
;;; associated with it, but no default initial-value form, then DEFVST
;;; picks some default value consistent with the restriction.
;;;
;;; Consider the example
;;; (DEFVST BANK
;;; (DOLLARS : (FIXNUM FLONUM MUMBLE))
;;; MANAGER
;;; (LIMIT = 1.0E6 : (FIXNUM FLONUM))
;;; &REST
;;; VAULTS 300.)
;;;
;;; First, the macro invocation of DEFVST would expand into
;;;
;;; (PROGN 'COMPILE
;;; (EVAL-WHEN (EVAL COMPILE LOAD)
;;; (DEFPROP BANK
;;; #((&STRUCT . BANK)
;;; CONS-A-BANK
;;; 3
;;; #((VAULTS BANK-VAULTS 30.)
;;; (DOLLARS BANK-DOLLARS 0 FIXNUM FLONUM MUMBLE)
;;; (MANAGER BANK-MANAGER)
;;; (LIMIT BANK-LIMIT 1.0E6 FIXNUM FLONUM)))
;;; STRUCT=INFO)
;;; (DEFPROP CONS-A-BANK BANK CONSTRUCTOR)
;;; (DEFPROP BANK-DOLLARS (BANK 1) SELECTOR)
;;; (DEFPROP BANK-MANAGER (BANK 2) SELECTOR)
;;; (DEFPROP BANK-LIMIT (BANK 3) SELECTOR)
;;; (DEFPROP BANK-VAULTS (BANK 4 &REST) SELECTOR))
;;; (MACRO CONS-A-BANK (BANK-MACRO-ARG)
;;; (|defvst-construction/|| 'BANK BANK-MACRO-ARG))
;;; (MACRO BANK-DOLLARS (BANK-MACRO-ARG)
;;; `(VREF ,(cadr bank-macro-arg) 1))
;;; (MACRO BANK-MANAGER (BANK-MACRO-ARG)
;;; `(VREF ,(cadr bank-macro-arg) 2))
;;; (MACRO BANK-LIMIT (BANK-MACRO-ARG)
;;; `(VREF ,(cadr bank-macro-arg) 3))
;;; (MACRO BANK-VAULTS (BANK-MACRO-ARG)
;;; `(VREF ,(cadr bank-macro-arg)
;;; (+ 4 ,(caddr bank-macro-arg)))))
;;; which is then evaluated, producing the four macro definitions, and
;;; DEFPROPping several informational properties.
;;; After that, then, a "simple" creation instance is invoked by, say,
;;; (CONS-A-BANK)
;;; then yields a vector something like
;;; #( (&STRUCT . BANK) 0 () 1.0E6 () . . . () )
;;; - a bank with three named components, and with 30. unnamed
;;; components which are accessed as if VAULTS were a vector name.
;;; Note that the first element of the vector is a special
;;; "structure" indicator, so that code may certify whether something
;;; is indeed a structure. But a more complex invocation
;;;
;;;
;;; (CONS-A-BANK DOLLARS (CASEQ VIP
;;; (FEDERAL 15.0E9)
;;; (SAVINGS-&-LOAN 10.0E6)
;;; (MICKEY-MOUSE 1))
;;; LIMIT (BANK-DOLLARS CURRENT-CONSTRUCTION)
;;; VAULTS 12.)
;;;
;;; illustrates three points of a creating instance - -
;;; (1) keywords paired with initial values are just alternating
;;; pairs in the list, and
;;; (2) the forms for initial values are substituted into a piece of
;;; code output by the macro, so that they are evaluated at
;;; instantiation time, and
;;; (3) the variable CURRENT-CONSTRUCTION is dynamically bound to the
;;; structure being created so that it may be referenced; the
;;; installing of initial values happens last.
;;; Notice how this macro-expands --
;;;
;;; (LET ((CURRENT-CONSTRUCTION (MAKE-VECTOR (1+ 41))))
;;; (VSET CURRENT-CONSTRUCTION 0 (|defvst-getmarker/||))
;;; (SETVST (BANK-DOLLARS CURRENT-CONSTRUCTION)
;;; (|defvst-typchk/|| (CASEQ VIP
;;; (FEDERAL 1.5E+10)
;;; (SAVINGS-&-LOAN 10000000.0)
;;; (MICKEY-MOUSE 1))
;;; '(FIXNUM FLONUM MUMBLE)
;;; 'BANK-DOLLARS))
;;; (SETVST (BANK-LIMIT CURRENT-CONSTRUCTION)
;;; (|defvst-typchk/|| (BANK-DOLLARS CURRENT-CONSTRUCTION)
;;; '(FIXNUM FLONUM)
;;; 'BANK-LIMIT))
;;; CURRENT-CONSTRUCTION)
;;;
;;; This code might actually not run, since it could stop on a Restriction
;;; Violation if the variable VIP does not have a value among
;;; {FEDERAL, SAVINGS-&-LOAN, MICKEY-MOUSE}
;;; for then it would turn up a () for the DOLLARS component, which
;;; was specified to be restricted to fixnums.
(comment "conditional" macros)
(eval-when (eval compile)
(macro IF-MACLISP (x)
(and (status feature MACLISP)
`(PROGN 'COMPILE ,@(cdr x))))
(macro IF-NOT-MACLISP (x)
(and (not (status feature MACLISP))
`(PROGN 'COMPILE ,@(cdr x))))
(macro IF-LISPM (x)
(and (status feature LISPM)
`(PROGN 'COMPILE ,@(cdr x))))
(macro IF-NOT-LISPM (x)
(and (not (status feature LISPM))
`(PROGN 'COMPILE ,@(cdr x))))
(macro IF-NIL (x)
(and (status feature NIL)
`(PROGN 'COMPILE ,@(cdr x))))
(macro IF-NOT-NIL (x)
(and (not (status feature NIL))
`(PROGN 'COMPILE ,@(cdr x))))
)
(IF-MACLISP
(DECLARE (OWN-SYMBOL STRING-APPEND VECTORP VECTOR MAKE-VECTOR VREF VSET)
(*EXPR VECTORP VECTOR MAKE-VECTOR VREF VSET))
)
(eval-when (eval compile)
(IF-MACLISP
(defun macro-fun-get macro (x) `(GET ,(cadr x) 'MACRO))
)
(IF-NOT-MACLISP
(defun MACRO-FUN-GET macro (x)
(let ((g (gensym)))
`((LAMBDA (,g)
(AND (SYMBOLP ,g)
(FBOUNDP ,g)
(SETQ ,g (FSYMEVAL ,g))
(NOT (ATOM ,g ))
(EQ (CAR ,g) 'MACRO)
(CDR ,g)))
,(cadr x))))
))
(IF-MACLISP (eval-when (eval compile load)
(and (not (or (macro-fun-get 'SETF) (get 'SETF 'SUBR)))
(macro SETF (x) `(SETVST ,.(cdr x))))
))
(comment VECTOR and STRING compatibility code for maclisp and lispm)
(IF-NOT-NIL (eval-when (eval compile load)
;;; Many functions of one argument can be macro-expanded, providing
;;; that the argument-form can be multiplied. If not, then we must
;;; wrap a LAMBDA around it, and give it an argument-form of a symbol.
(DEFMACRO (DEFSIMPLEMAC DEFMACRO-FOR-COMPILING ()
DEFMACRO-DISPLACE-CALL () )
(NAME VARS /&REST BODY)
(AND (OR (ATOM VARS) (NOT (SYMBOLP (CAR VARS))) (CDR VARS))
(ERROR '|Bad arglist for DEFSIMPLEMAC| `(,name ,vars ,@body)))
`(DEFMACRO ,name ,vars
(COND ((|no-funp/|| ,(car vars))
,(cond ((cdr body) '(cons 'PROGN body))
((car body))))
((LET ((G (GENSYM)))
`((LAMBDA (,g) (,',name ,g)) ,,(car vars)))))))
(DEFSIMPLEMAC (|very-simplep/|| DEFMACRO-FOR-COMPILING ()
DEFMACRO-DISPLACE-CALL () )
(X)
`(CASEQ (TYPEP ,x)
(SYMBOL ())
(LIST (MEMQ (CAR ,x) '(QUOTE FUNCTION)))
(T T)))
(DEFUN |no-funp/|| (X)
(COND ((OR (ATOM X) (MEMQ (CAR X) '(QUOTE FUNCTION DECLARE))))
((NOT (ATOM (CAR X))) () )
((OR (EQ 'CXR (CAR X)) (|carcdrp/|| (CAR X)))
(|no-funp/|| (CADR X))) ))
(DEFUN |carcdrp/|| (X)
(AND (SYMBOLP X)
(LET ( (N (FLATC X)) )
(DECLARE (FIXNUM N))
(COND ((OR (NOT (LESSP 2 N 7))
(NOT (EQ (GETCHAR X 1) 'C))
(NOT (EQ (GETCHAR X N) 'R)))
() )
((PROG (TMP)
A (AND (< (SETQ N (1- N)) 2) (RETURN 'T))
(SETQ TMP (GETCHAR X N))
(AND (NOT (MEMQ TMP '(A D))) (RETURN () ))
(GO A)))))))
;;; Still within the IF-NOT-NIL
(DEFUN |side-effectsp/|| (X)
(COND ((ATOM X) () )
((MEMQ (CAR X) '(QUOTE FUNCTION DECLARE)) () )
((AND (NOT (ATOM (CAR X)))
(EQ (CAAR X) 'LAMBDA))
(OR (MAPCAN '|side-effectsp/|| (CDDAR X))
(MAPCAN '|side-effectsp/|| (CDR X))))
((OR (NOT (SYMBOLP (CAR X))) (GET (CAR X) 'FSUBR)) (LIST 'T))
((|carcdrp/|| (CAR X)) (|side-effectsp/|| (CADR X)))
((OR (MEMQ (CAR X) '(CONS NCONS XCONS ASSQ ASSOC COPYSYMBOL GET GETL
GETCHAR GETCHARN IMPLODE LAST LIST LISTIFY PNGET
EXPLODE EXPLODEC EXPLODEN FLATC FLATSIZE INTERN
HUNK LISTARRAY MAKHUNK MAKNAM PLIST
MEMQ MEMBER SUBLIS SUBST REVERSE APPEND
BIGP EQUAL EQ FIXP FLOATP NUMBERP SYMBOLP TYPEP
NOT NULL ODDP GREATERP LESSP PLUSP MINUSP ZEROP
FILEP FASLP PROBEF NAMELIST NAMESTRING TRUENAME
))
(MEMQ (CAR X) '(PLUS DIFFERENCE TIMES QUOTIENT ADD1 SUB1 ABS
+ - * // 1+ 1- ā +$ -$ *$ //$ 1+$ 1-$ ā$
\ \\ REMAINDER GCD EXP EXPT BOOLE > < =
IFIX FIX LOG SQRT SIN COS ROT LSH FSC
HAIPART HAULONG HUNKSIZE LENGTH SXHASH
))
(MEMQ (CAR X) '(ELT VREF VECTORP VECTOR MAKE-VECTOR VECTOR-LENGTH
>= <= <$ <=$ =$ >=$ >$
FIXNUMP LIST-LENGTH NNLISTP CHARACTERP
GET-PNAME STRING-APPEND STRINGP STRING-LENGTH
)))
(MAPCAN '|side-effectsp/|| (CDR X)))
((LET* ( (OCARX (CAR X)) (OCDRX (CDR X)) (Y (MACROEXPAND X)) )
(COND ((AND (EQ X Y) (EQ OCARX (CAR Y)) (EQ OCDRX (CDR Y)))
(LIST 'T))
((|side-effectsp/|| Y)))))))
))
(IF-MACLISP
(eval-when (compile)
(own-symbol '(STRING-APPEND GET-PNAME <= >=
VECTORP VECTOR MAKE-VECTOR VREF VSET)) )
(eval-when (eval)
(mapc 'remob '(STRING-APPEND GET-PNAME <= >=
VECTORP VECTOR MAKE-VECTOR VREF VSET)) )
)
(IF-MACLISP
(defmacro (GET-PNAME DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () ) (x)
x)
(defun STRING-APPEND n
(do ((i 1 (1+ i)) (item) (z) )
((> i n) (implode (nreverse z)))
(setq item (arg i))
(and (not (symbolp item)) (error '|wta - STRING-APPEND| item))
(setq z (nreconc (exploden item) z)) ))
(defmacro (<= DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () ) (X Y)
`(NOT (> ,x ,y)))
(defmacro (>= DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () ) (X Y)
`(NOT (< ,x ,y)))
(defmacro VECTORP (x) `(HUNKP ,x))
(defmacro MAKE-VECTOR (x) `(MAKHUNK ,x))
(defmacro VECTOR (&REST H)
(COND ((OR (|very-simplep/|| (CAR H))
(DO ((Y (CDR H) (CDR Y)))
((NULL Y) 'T)
(AND (NOT (|very-simplep/|| (CAR Y))) (RETURN ())))
(DO ((Y H (CDR Y)))
((NULL Y) 'T)
(AND (OR (|side-effectsp/|| (CAR Y)) (|side-effectsp/|| H))
(RETURN () ))))
`(HUNK ,@(cdr h) ,(car h)))
((LET ((G (GENSYM)))
`((LAMBDA (,g) (HUNK ,@(cdr h) ,g)) ,(car h))))))
(DEFMACRO VREF (H N)
(COND ((OR (|very-simplep/|| H)
(|very-simplep/|| N)
(AND (NOT (|side-effectsp/|| N)) (NOT (|side-effectsp/|| H))))
`(CXR ,n ,h))
(`((LAMBDA (H N) (CXR N H)) ,h ,n))))
(DEFMACRO VSET (H N VAL)
(COND ((OR (|very-simplep/|| H)
(|very-simplep/|| N)
(AND (NOT (|side-effectsp/|| N)) (NOT (|side-effectsp/|| H))))
`(RPLACX ,n ,h ,val))
(`((LAMBDA (H N VAL) (RPLACX N H VAL))
,h ,n ,val))))
)
(IF-LISPM
(DEFUN VECTORP (X)
(AND (ARRAYP X)
(EQ (ARRAY-TYPE X) 'ART-Q)
(= (ARRAY-/#-DIMS X) 1)))
(DEFMACRO MAKE-VECTOR (N) `(MAKE-ARRAY () 'ART-Q ,n))
(DEFMACRO VECTOR (/&REST X)
`(FILLARRAY
(MAKE-ARRAY () 'ART-Q ,(length x))
(LIST ,@x)))
(DEFMACRO VREF (H N) `(AR-1 H ,n))
(DEFMACRO VSET (H N VAL)
(COND ((OR (|side-effectsp/|| H)
(|side-effectsp/|| N)
(|side-effectsp/|| VAL))
`((LAMBDA (H N VAL) (AS-1 VAL H N))
,h ,n ,val))
(`(AS-1 ,val ,h ,n))))
)
(comment BASIC defvst stuff)
(declare (setq defmacro-for-compiling () ))
(macro cmptime-eval (x) (and (eval (cadr x)) (eval (caddr x))))
(cmptime-eval T
`(OR (STATUS FEATURE NOLDMSG)
(PROG2 (TERPRI)
(PRINC ',(implode (nconc (exploden '|;Loading DEFVST |)
(do ((x (exploden
(cond ((caddr (truename infile)))
('/34)))
(cdr x)))
((lessp 47. (car x) 58.)
x))
(exploden '| |)))))))
(DECLARE (SPECIAL DEFMACRO-DISPLACE-CALL
CURRENT-CONSTRUCTION
CONSTRUCTOR-NAMESTRING-PREFIX
SELECTOR-NAMESTRING-STYLE)
(*EXPR |defvst-typchk/||
|defvst-construction/||
|defvst-instantiate/||
|defvst-getmarker/||))
(EVAL-WHEN (COMPILE)
(SETQ DEFMACRO-CHECK-ARGS ()
DEFMACRO-FOR-COMPILING 'T
DEFMACRO-DISPLACE-CALL 'T))
(AND (NOT (BOUNDP 'SELECTOR-NAMESTRING-STYLE))
(SETQ SELECTOR-NAMESTRING-STYLE '|-|))
(AND (NOT (BOUNDP 'CONSTRUCTOR-NAMESTRING-PREFIX))
(SETQ CONSTRUCTOR-NAMESTRING-PREFIX '|CONS-A-|))
;;; The macros below represent a "hand-made" structure for the information
;;; structure kept for STRUCTs, which might have been from
;;; (DEFVST STRUCT=INFO INDC CNSN SIZE INIS)
(cmptime-eval T
`(PROGN 'COMPILE
(EVAL-WHEN (COMPILE EVAL LOAD)
(DEFPROP CONS-A-STRUCT=INFO STRUCT=INFO CONSTRUCTOR)
(DEFPROP STRUCT=INFO-INDC (STRUCT=INFO 1) SELECTOR)
(DEFPROP STRUCT=INFO-CNSN (STRUCT=INFO 2) SELECTOR)
(DEFPROP STRUCT=INFO-SIZE (STRUCT=INFO 3) SELECTOR)
(DEFPROP STRUCT=INFO-INIS (STRUCT=INFO 4) SELECTOR)
(DEFPROP STRUCT=INFO
,(vector ;Internal struct marker
'(&STRUCT . STRUCT=INFO)
;Indicator+Generic name
'(&STRUCT . STRUCT=INFO)
;Constructor-macro name
'CONS-A-STRUCT=INFO
;Number of named keys
4
(vector ;&REST key/selector/len
()
;Key-names with info for default
'(indc struct=info-indc ())
; initial settings
'(cnsn struct=info-cnsn ())
'(size struct=info-size 0)
'(inis struct=info-inis ())))
STRUCT=INFO)
)
(MACRO CONS-A-STRUCT=INFO (x)
(|defvst-construction/|| 'STRUCT-INFO x))
(MACRO STRUCT=INFO-INDC (x) `(VREF ,(cadr x) 1))
(MACRO STRUCT=INFO-CNSN (x) `(VREF ,(cadr x) 2))
(MACRO STRUCT=INFO-SIZE (x) `(VREF ,(cadr x) 3))
(MACRO STRUCT=INFO-INIS (x) `(VREF ,(cadr x) 4)))
)
(DEFUN (DEFVST-DEFMACRO MACRO) (X)
(CONS (COND (DEFMACRO-DISPLACE-CALL '|MACRO-macroexpander/||)
('MACRO))
(CDR X)))
(DEFUN (DEFVST MACRO) (X)
(LET ( (SELKEYS (CDDR X)) (SNAME (CADR X)) (NKEYS 0)
;Would like ((() SNAME . SELKEYS) X)
(DEFMACRO-DISPLACE-CALL DEFMACRO-DISPLACE-CALL)
(SELECTOR-NAMESTRING-STYLE SELECTOR-NAMESTRING-STYLE)
(CONSTRUCTOR-NAMESTRING-PREFIX CONSTRUCTOR-NAMESTRING-PREFIX)
CONSTRUCTOR-NAME RESTP RESTKEY RESTSIZEFORM TYP TMP
SELMACDEFS SELDEFPROPS SELINIS MAC-ARG-NM )
(DECLARE (FIXNUM I NKEYS))
(COND ((NOT (ATOM SNAME))
(DO L (CDR SNAME) (CDDR L) (NULL L)
(SET (CAR L) (EVAL (CADR L))))
(SETQ SNAME (CAR SNAME))))
(AND (OR (NULL SNAME) (NOT (SYMBOLP SNAME)) (ATOM SELKEYS))
(ERROR '|Bad args - DEFVST| X))
(SETQ NKEYS (LENGTH SELKEYS))
(COND ((SETQ TMP (MEMQ '&REST SELKEYS))
(SETQ NKEYS (- NKEYS (LENGTH TMP))
RESTKEY (CADR TMP)
RESTSIZEFORM (CADDR TMP))
(AND (OR (NOT (SYMBOLP RESTKEY)) (NULL RESTSIZEFORM))
(ERROR '|Lossage in &REST variable - DEFVST| SELKEYS))))
(COND ((GET SNAME 'STRUCT=INFO)
(TERPRI MSGFILES)
(PRINC '|Warning! Redefining the STRUCTURE | MSGFILES)
(PRIN1 SNAME MSGFILES)))
(SETQ MAC-ARG-NM
(INTERN (STRING-APPEND (GET-PNAME SNAME)
(GET-PNAME '|-MACRO-ARG|))))
(SETQ CONSTRUCTOR-NAME
(INTERN (STRING-APPEND (GET-PNAME CONSTRUCTOR-NAMESTRING-PREFIX)
(GET-PNAME SNAME))))
; RESTP and SELINIS start out null here
(DO ( (I 1 (1+ I)) (L SELKEYS (CDR L)) (FLAG) (KEYNM) (SELNM) )
( (OR (NULL L) RESTP) )
(COND ((ATOM (SETQ KEYNM (CAR L)))
(COND ((EQ KEYNM '&REST)
(SETQ KEYNM RESTKEY RESTP 'T)
(AND (NOT (EQ RESTKEY (CADR L)))
(ERROR '|&REST lossage DEFVST|))))
(SETQ TMP () ))
('T (AND (OR (NULL (SETQ KEYNM (CAR KEYNM)))
(NOT (SYMBOLP KEYNM)))
(ERROR '|Bad key-list - DEFVST| SELKEYS))
(COND ((ATOM (CDAR L)) (SETQ TMP () ))
('T (SETQ FLAG () )
(AND (SETQ TYP (MEMQ '|:| (CDAR L)))
(PROG2 (SETQ FLAG 'T) 'T)
(SETQ TYP (COND ((ATOM (CADR TYP))
(LIST (CADR TYP)))
((CADR TYP)))))
(SETQ TMP (COND ((SETQ TMP (MEMQ '= (CDAR L)))
(SETQ FLAG 'T)
(CADR TMP))
(TYP (CDR (ASSQ (CAR TYP)
'((FIXNUM . 0)
(FLONUM . 0.0)
(BIGNUM . 500000000000000000000.)
(SHORTFLOAT 0.0)
(LIST . () )
(SYMBOL . FOO)
(VECTOR . () ) ;change this
(ARRAY . () ) ;crap in the
(HUNK . () ) ;real NIL !
)))) ))
(AND (NOT FLAG)
(ERROR '|Invalid initialization or restriction - DEFVST|
(CAR L)))
(SETQ TMP (CONS TMP TYP)))) ))
(SETQ SELNM (COND ((NULL SELECTOR-NAMESTRING-STYLE) KEYNM)
((INTERN (STRING-APPEND (GET-PNAME SNAME)
(GET-PNAME SELECTOR-NAMESTRING-STYLE)
(GET-PNAME KEYNM))))))
(PUSH (COND ((NOT RESTP)
;TMP has "(<initialization-form> <restrictions> ... )"
(PUSH `(QUOTE (,keynm ,selnm ,@tmp)) SELINIS)
`(DEFVST-DEFMACRO ,selnm (,mac-arg-nm)
`(VREF ,(cadr ,mac-arg-nm) ,,i)))
('T (SETQ RESTP `(QUOTE (,keynm ,selnm ,restsizeform)))
`(DEFVST-DEFMACRO ,selnm (,mac-arg-nm)
`(VREF ,(cadr ,mac-arg-nm)
(+ ,,(1+ nkeys) ,(caddr ,mac-arg-nm))))))
SELMACDEFS)
(PUSH `(DEFPROP ,selnm
(,sname ,i . ,(and restp '(&REST)))
SELECTOR)
SELDEFPROPS))
`(PROGN 'COMPILE
(EVAL-WHEN (EVAL COMPILE LOAD)
(DEFPROP ,sname
,(vector (get 'STRUCT=INFO 'STRUCT=INFO)
(cons '&STRUCT sname)
constructor-name
nkeys
(eval (list* 'vector
restp
(nreverse selinis))))
STRUCT=INFO)
(DEFPROP ,constructor-name ,sname CONSTRUCTOR)
,@(nreverse seldefprops) )
(DEFVST-DEFMACRO ,constructor-name (,mac-arg-nm)
(|defvst-construction/|| ',sname ,mac-arg-nm))
,@(nreverse selmacdefs)
',sname)))
(comment RUN-TIME SUPPORT CODE)
(DEFUN |defvst-getmarker/|| ()
(PROG (SINFO)
A (COND ((NULL (SETQ SINFO (GET 'STRUCT=INFO 'STRUCT=INFO)))
(BREAK |Please Load DEFVST|)
(GO A)))
(RETURN (STRUCT=INFO-INDC SINFO))))
(DEFUN (SETVST MACRO) (X)
(LET ((VAL (NTH 2 X)) (ARGL (NTH 1 X)) LL SNAME)
;Would like ((() (SNAME . ARGL) VAL) X)
(SETQ SNAME (CAR ARGL) ARGL (CDR ARGL))
(AND (OR (NULL ARGL)
(NOT (SYMBOLP SNAME))
;either (NAME i) or (NAME i &REST)
(AND (SETQ LL (GET SNAME 'SELECTOR))
(OR (COND ((NULL (CDDR LL)) (CDR ARGL))
('T (NULL (CDR ARGL))))
(CDDR ARGL)))
(DO ((X (CADR X) (MACROEXPAND-1 X))
(BX) (BC) (DEFMACRO-DISPLACE-CALL () ))
((OR (ATOM X)
(AND (EQ X BX) (EQ (CAR X) BC))
(EQ (CAR X) 'VREF))
(NOT (EQ (CAR (SETQ LL X)) 'VREF)))
(SETQ BC (CAR (SETQ BX X)))))
(ERROR '|Incorrect selector - SETVST| SNAME))
`(VSET ,@(cdr ll) ,val)))
(DEFUN |defvst-typchk/|| (VAL TYPL ACCESSOR-MAC)
(PROG (NTYP SNAME KEY)
A (AND (MEMQ (SETQ NTYP (TYPEP VAL)) TYPL) (RETURN VAL))
;Accessor-macro name has a SELECTOR property of "(<sname> <index>)"
; where <sname> is the structure name, and <index> is the vector
; index corresponding to the key-name
;For now, the first slot of a structure-vector is taken up by the
; &STRUCT marker, so the access of the initializations list(vector)
; must be made to correspond.
(AND (NULL SNAME)
(SETQ SNAME (NTH 0 (SETQ NTYP (GET ACCESSOR-MAC 'SELECTOR)))
KEY (CAR (VREF (STRUCT=INFO-INIS (GET SNAME 'STRUCT=INFO))
(COND ((EQ (NTH 2 NTYP) '&REST) 0)
((NTH 1 NTYP)))))))
(TERPRI MSGFILES)
(PRINC '|Restriction Violation while creating a structure. The |
MSGFILES)
(PRIN1 KEY MSGFILES)
(PRINC '| component of | MSGFILES)
(PRIN1 SNAME MSGFILES)
(PRINC '| is being set to | MSGFILES)
(PRIN1 VAL MSGFILES)
(PRINC '|, which is supposed to be of type | MSGFILES)
(PRIN1 (SETQ NTYP (COND ((CDR TYPL) TYPL) ((CAR TYPL)))) MSGFILES)
(SETQ VAL (ERROR '|DEFVST Restriction Violation|
(LIST SNAME KEY VAL NTYP)
'WRNG-TYPE-ARG))
(GO A)))
(DEFUN |defvst-construction/|| (SNAME ARGL)
(PROG (SINFO OVERRIDES INIS ACCESSOR-MAC BL OL NOL RESTP NKEYS TOTSIZE TMP)
(DECLARE (FIXNUM NKEYS TOTSIZE))
(AND (SETQ OVERRIDES (CDR ARGL)) (PUSH () OVERRIDES))
(AND (NOT (VECTORP (SETQ SINFO (GET SNAME 'STRUCT=INFO))))
(ERROR '|defvst-construction/|| ARGL))
;;; The following could be (DESETQ ((&STRUCT . STRUCT=INFO)
;;; INIS INIS
;;; SIZE NKEYS)
;;; SINFO)
(SETQ INIS (STRUCT=INFO-INIS SINFO)
NKEYS (STRUCT=INFO-SIZE SINFO))
(SETQ RESTP (VREF INIS 0))
(SETQ TOTSIZE NKEYS)
(AND RESTP
(SETQ TOTSIZE
(+ TOTSIZE (COND ((AND OVERRIDES (SETQ TMP (GET (CAR RESTP)
OVERRIDES)))
(COND ((EQ (TYPEP TMP) 'FIXNUM))
((>= TMP 0))
((ERROR '|Bad &REST arg quantity|
ARGL)))
TMP)
((CADDR RESTP))))))
(DO ( (I NKEYS (1- I)) (FLAG () () ) KEYNAME TYPL FORM )
( (<= I 0) )
(DESETQ (KEYNAME ACCESSOR-MAC FORM . TYPL) (VREF INIS I))
(AND (SETQ TMP (GETL OVERRIDES (LIST KEYNAME)))
(SETQ FORM (CADR TMP) FLAG 'T))
(AND FORM
(SETQ FORM `(SETVST (,accessor-mac CURRENT-CONSTRUCTION)
,(cond ((null typl) form)
(`(|defvst-typchk/||
,form
',typl
',accessor-mac)))))
(COND (FLAG (PUSH (CONS KEYNAME FORM) OL))
('T (PUSH FORM BL)))))
(AND OL (DO L (CDR OVERRIDES) (CDDR L) (NULL L)
(AND (SETQ TMP (ASSQ (CAR L) OL))
(PUSH (CDR TMP) NOL))))
(RETURN `(LET ( (CURRENT-CONSTRUCTION (MAKE-VECTOR ,(1+ totsize))) )
(VSET CURRENT-CONSTRUCTION
0
(STRUCT=INFO-INDC (get ',sname 'STRUCT=INFO)))
,@(nreverse bl)
,@(nreverse nol)
CURRENT-CONSTRUCTION))))
(comment REMOBs for compatibility functions)
(IF-NOT-NIL (eval-when (eval compile load)
(mapc 'REMOB '(VECTORP VECTOR MAKE-VECTOR VREF VSET))
))
(IF-MACLISP (eval-when (eval compile load)
(remob 'STRING-APPEND)
))